home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / rmail / undigest.el.z / undigest.el
Encoding:
Text File  |  1998-05-21  |  4.3 KB  |  138 lines
  1. ;;; undigest.el --- digest-cracking support for the RMAIL mail reader
  2.  
  3. ;; Copyright (C) 1985, 1986, 1994 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6. ;; Keywords: mail
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Synched up with: FSF 19.30.
  26.  
  27. ;;; Commentary:
  28.  
  29. ;; See Internet RFC 934
  30.  
  31. ;;; Code:
  32.  
  33. (require 'rmail)
  34.  
  35. (defun undigestify-rmail-message ()
  36.   "Break up a digest message into its constituent messages.
  37. Leaves original message, deleted, before the undigestified messages."
  38.   (interactive)
  39.   (widen)
  40.   (let ((buffer-read-only nil)
  41.     (msg-string (buffer-substring (rmail-msgbeg rmail-current-message)
  42.                       (rmail-msgend rmail-current-message))))
  43.     (goto-char (rmail-msgend rmail-current-message))
  44.     (narrow-to-region (point) (point))
  45.     (insert msg-string)
  46.     (narrow-to-region (point-min) (1- (point-max))))
  47.   (let ((error t)
  48.     (buffer-read-only nil))
  49.     (unwind-protect
  50.     (progn
  51.       (save-restriction
  52.         (goto-char (point-min))
  53.         (delete-region (point-min)
  54.                (progn (search-forward "\n*** EOOH ***\n")
  55.                   (point)))
  56.         (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  57.         (narrow-to-region (point)
  58.                   (point-max))
  59.         (let* ((fill-prefix "")
  60.            (case-fold-search t)
  61.            start
  62.            (digest-name
  63.             (mail-strip-quoted-names
  64.              (or (save-restriction
  65.                (search-forward "\n\n")
  66.                (setq start (point))
  67.                (narrow-to-region (point-min) (point))
  68.                (goto-char (point-max))
  69.                (or (mail-fetch-field "Reply-To")
  70.                    (mail-fetch-field "To")
  71.                    (mail-fetch-field "Apparently-To")
  72.                    (mail-fetch-field "From")))
  73.              (error "Message is not a digest--bad header")))))
  74.           (save-excursion
  75.         (goto-char (point-max))
  76.         (skip-chars-backward " \t\n")
  77.         (let (found)
  78.           ;; compensate for broken un*x digestifiers.  Sigh Sigh.
  79.           (while (and (> (point) start) (not found))
  80.             (forward-line -1)
  81.             (if (looking-at (concat "End of.*Digest.*\n"
  82.                         (regexp-quote "*********") "*"
  83.                         "\\(\n------*\\)*"))
  84.             (setq found t)))
  85.           (if (not found)
  86.               (error "Message is not a digest--no end line"))))
  87.           (re-search-forward (concat "^" (make-string 55 ?-) "-*\n*"))
  88.           (replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  89.           (save-restriction
  90.         (narrow-to-region (point)
  91.                   (progn (search-forward "\n\n")
  92.                      (point)))
  93.         (if (mail-fetch-field "To") nil
  94.           (goto-char (point-min))
  95.           (insert "To: " digest-name "\n")))
  96.           (while (re-search-forward
  97.               (concat "\n\n" (make-string 27 ?-) "-*\n*")
  98.               nil t)
  99.         (replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  100.         (save-restriction
  101.           (if (looking-at "End ")
  102.               (insert "To: " digest-name "\n\n")
  103.             (narrow-to-region (point)
  104.                       (progn (search-forward "\n\n"
  105.                                  nil 'move)
  106.                          (point))))
  107.           (if (mail-fetch-field "To")
  108.               nil
  109.             (goto-char (point-min))
  110.             (insert "To: " digest-name "\n")))
  111.         ;; Digestifiers may insert `- ' on lines that start with `-'.
  112.         ;; Undo that.
  113.         (save-excursion
  114.           (goto-char (point-min))
  115.           (if (re-search-forward
  116.                "\n\n----------------------------*\n*"
  117.                nil t)
  118.               (let ((end (point-marker)))
  119.             (goto-char (point-min))
  120.             (while (re-search-forward "^- " end t)
  121.               (delete-char -2)))))
  122.         )))
  123.       (setq error nil)
  124.       (message "Message successfully undigestified")
  125.       (let ((n rmail-current-message))
  126.         (rmail-forget-messages)
  127.         (rmail-show-message n)
  128.         (rmail-delete-forward)
  129.         (if (rmail-summary-exists)
  130.         (rmail-select-summary
  131.          (rmail-update-summary)))))
  132.       (cond (error
  133.          (narrow-to-region (point-min) (1+ (point-max)))
  134.          (delete-region (point-min) (point-max))
  135.          (rmail-show-message rmail-current-message))))))
  136.  
  137. ;;; undigest.el ends here
  138.